home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MISC.SWG / 0076_UUEncode!.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-27  |  5KB  |  170 lines
  1. {
  2. > Yeah ! Please post your UU(EN/DE)CODE here ! I am interested, as well !
  3.  
  4. Here she goes then.
  5. }
  6.  
  7. PROGRAM uuencode;
  8.  
  9. Uses Dos,Crt;
  10.  
  11. CONST
  12.   Header = 'begin';
  13.   Trailer = 'end';
  14.   DefaultMode = '644';
  15.   DefaultExtension = '.uue';
  16.   OFFSET = 32;
  17.   CHARSPERLINE = 60;
  18.   BYTESPERHUNK = 3;
  19.   SIXBITMASK = $3F;
  20. TYPE
  21.   Str80 = STRING[80];
  22. VAR
  23.   Infile: FILE OF Byte;
  24.   Outfile: TEXT;
  25.   Infilename, Outfilename, Mode: Str80;
  26.   lineLength, numbytes, bytesInLine: INTEGER;
  27.   Line: ARRAY [0..59] OF CHAR;
  28.   hunk: ARRAY [0..2] OF Byte;
  29.   chars: ARRAY [0..3] OF Byte;
  30.   size,remaining : longint;  {v1.1 REAL;}
  31. PROCEDURE Abort (Msg : Str80);
  32.   BEGIN
  33.     WRITELN(Msg);
  34.     {$I-}                 {v1.1}
  35.     CLOSE(Infile);
  36.     CLOSE(Outfile);
  37.     {$I+}                 {v1.1}
  38.     HALT
  39.   END; {of Abort}
  40. PROCEDURE Init;
  41.   PROCEDURE GetFiles;
  42.     VAR
  43.       i : INTEGER;
  44.       TempS : Str80;
  45.       Ch : CHAR;
  46.     BEGIN
  47.       IF ParamCount < 1 THEN Abort ('No input file specified.');
  48.       Infilename := ParamStr(1);
  49.       {$I-}
  50.       ASSIGN (Infile, Infilename);
  51.       RESET (Infile);
  52.       {$I+}
  53.       IF IOResult > 0 THEN Abort (CONCAT ('Can''t open file ', Infilename));
  54.       size := FileSize(Infile);
  55. {     IF size < 0 THEN size:=size+65536.0; }
  56.       remaining := size;
  57.       WRITE('Uuencoding file ', Infilename);
  58.       i := POS('.', Infilename);
  59.       IF i = 0
  60.       THEN Outfilename := Infilename
  61.       ELSE Outfilename := COPY (Infilename, 1, PRED(i));
  62.       Mode := DefaultMode;
  63.       { Process 2d cmdline arg (if any).
  64.         It could be a new mode (rather than default "644")
  65.         or it could be a forced output name (rather than
  66.         "infile.uue")       }
  67.       IF ParamCount > 1                         {got more args}
  68.       THEN FOR i := 2 TO ParamCount DO BEGIN
  69.         TempS := ParamStr(i);
  70.         IF TempS[1] IN ['0'..'9']               {numeric : it's a mode}
  71.         THEN Mode := TempS
  72.         ELSE Outfilename := TempS               {it's output filename}
  73.       END;
  74.       IF POS ('.', Outfilename) = 0       {he didn't give us extension..}
  75.                                           {..so make it ".uue"}
  76.       THEN Outfilename := CONCAT(Outfilename, DefaultExtension);
  77.       ASSIGN (Outfile, Outfilename);
  78.       WRITELN (' to file ', Outfilename, '.');
  79.       {$I-}
  80.       RESET(Outfile);
  81.       {$I+}
  82.       IF IOResult = 0 THEN BEGIN          {output file exists!}
  83.         WRITE ('Overwrite current ', Outfilename, '? [Y/N] ');
  84.         REPEAT
  85.           Ch := Upcase(ReadKey);
  86.         UNTIL Ch IN ['Y', 'N'];
  87.         WRITELN (Ch);
  88.         IF Ch = 'N' THEN Abort(CONCAT (Outfilename, ' not overwritten.'))
  89.       END;
  90.       {$I-}
  91.       CLOSE(Outfile);
  92.       IF IOResult <> 0 THEN ;  {v1.1 we don't care}
  93.       REWRITE(Outfile);
  94.       {$I+}
  95.       IF IOResult > 0 THEN Abort(CONCAT('Can''t open ', Outfilename));
  96.     END; {of GetFiles}
  97.   BEGIN {Init}
  98.     GetFiles;
  99.     bytesInLine := 0;
  100.     lineLength := 0;
  101.     numbytes := 0;
  102.     WRITELN (Outfile, Header, ' ', Mode, ' ', Infilename);
  103.   END; {init}
  104. {You'll notice from here on we don't do any error-trapping on disk
  105.  read/writes.  We just let DOS do the job.  Any errors are terminal
  106.  anyway, right? }
  107. PROCEDURE FlushLine;
  108.   VAR i: INTEGER;
  109.   PROCEDURE WriteOut(Ch: CHAR);
  110.     BEGIN
  111.       IF Ch = ' ' THEN WRITE(Outfile, '`')
  112.                   ELSE WRITE(Outfile, Ch)
  113.     END; {of WriteOut}
  114.   BEGIN {FlushLine}
  115.     {write ('.');}
  116.     WRITE('bytes remaining: ',remaining:7,' (',
  117.           remaining/size*100.0:3:0,'%)',CHR(13));
  118.     WriteOut(CHR(bytesInLine + OFFSET));
  119.     FOR i := 0 TO PRED(lineLength) DO
  120.       WriteOut(Line[i]);
  121.     WRITELN (Outfile);
  122.     lineLength := 0;
  123.     bytesInLine := 0
  124.   END; {of FlushLine}
  125. PROCEDURE FlushHunk;
  126.   VAR i: INTEGER;
  127.   BEGIN
  128.     IF lineLength = CHARSPERLINE THEN FlushLine;
  129.     chars[0] := hunk[0] ShR 2;
  130.     chars[1] := (hunk[0] ShL 4) + (hunk[1] ShR 4);
  131.     chars[2] := (hunk[1] ShL 2) + (hunk[2] ShR 6);
  132.     chars[3] := hunk[2] AND SIXBITMASK;
  133.     {debug;}
  134.     FOR i := 0 TO 3 DO BEGIN
  135.       Line[lineLength] := CHR((chars[i] AND SIXBITMASK) + OFFSET);
  136.       {write(line[linelength]:2);}
  137.       Inc(lineLength);
  138.     END;
  139.     {writeln;}
  140.     Inc(bytesInLine,numbytes);
  141.     numbytes := 0
  142.   END; {of FlushHunk}
  143. PROCEDURE Encode1;
  144.   BEGIN
  145.     IF numbytes = BYTESPERHUNK THEN FlushHunk;
  146.  
  147.     READ (Infile, hunk[numbytes]);
  148.     Dec(remaining);
  149.     Inc(numbytes);
  150.   END; {of Encode1}
  151. PROCEDURE Terminate;
  152.   BEGIN
  153.     IF numbytes > 0 THEN FlushHunk;
  154.     IF lineLength > 0 THEN BEGIN
  155.       FlushLine;
  156.       FlushLine;
  157.     END
  158.     ELSE FlushLine;
  159.     WRITELN (Outfile, Trailer);
  160.     CLOSE (Outfile);
  161.     CLOSE (Infile);
  162.   END; {Terminate}
  163. BEGIN {uuencode}
  164.   Init;
  165.   WHILE NOT EOF (Infile) DO Encode1;
  166.   Terminate;
  167.   WRITELN;
  168. END. {uuencode}
  169.  
  170.